home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue28 / subclass / app1main.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-09-05  |  3.0 KB  |  107 lines
  1. unit app1main;
  2. interface
  3. uses
  4.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  5.   StdCtrls;
  6.  
  7. type
  8.   TMyForm = class(TForm)
  9.     Button1: TButton;
  10.     Button2: TButton;
  11.     procedure FormCreate(Sender: TObject);
  12.     procedure FormDestroy(Sender: TObject);
  13.     procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
  14.       Shift: TShiftState; X, Y: Integer);
  15.     procedure Button1Click(Sender: TObject);
  16.     procedure Button2Click(Sender: TObject);
  17.   private
  18.     procedure TurnSubClassOn;
  19.   public
  20.     { Public declarations }
  21.   end;
  22.  
  23. var
  24.   MyForm: TMyForm;
  25.  
  26. function NewFormFunction(handle: hWnd; msg, wParam : Word; lParam : LongInt): LongInt; stdcall;
  27. function AlternateNewFormFunction(handle: hWnd; msg, wParam : Word; lParam : LongInt): LongInt; stdcall;
  28.  
  29.  
  30. var
  31.    NewWindowProc : TFarProc;  {pointer to our window function}
  32.    OldWindowProcAddr : LongInt;   {previous window function (LongInt) }
  33.    TargetHandle : hWnd;
  34.  
  35. implementation
  36.  
  37. {$R *.DFM}
  38.  
  39. function NewFormFunction(handle: hWnd; msg, wParam : Word; lParam : LongInt): LongInt;
  40. begin
  41.   case msg of
  42.      WM_LBUTTONDOWN : MyForm.color := clLime;
  43.      WM_RBUTTONDOWN : MyForm.color := clWhite;
  44.      end;
  45.   Result := CallWindowProc(TfarProc(OldWindowProcAddr), Handle, Msg, wParam, lParam);
  46. end;
  47.  
  48. function AlternateNewFormFunction(handle: hWnd; msg, wParam : Word; lParam : LongInt): LongInt;
  49. begin
  50.   Result := CallWindowProc(TfarProc(OldWindowProcAddr), Handle, Msg, wParam, lParam);
  51.   case msg of
  52.      WM_LBUTTONDOWN : MyForm.color := clLime;
  53.      WM_RBUTTONDOWN : MyForm.color := clWhite;
  54.      end;
  55. end;
  56.  
  57. Procedure tmyForm.TurnSubClassOn;
  58. begin
  59.    TargetHandle := handle;
  60.    OldWindowProcAddr := GetWindowLong(TargetHandle, GWL_WNDPROC);
  61.    NewWindowProc := @NewFormFunction;
  62.    SetWindowLong(TargetHandle, GWL_WNDPROC, LongInt(NewWindowProc));
  63. end;
  64.  
  65.  
  66. procedure TMyForm.FormCreate(Sender: TObject);
  67. begin
  68.   TurnSubClassOn;
  69.   OnMouseDown := nil;
  70. end;
  71.  
  72. procedure TMyForm.FormDestroy(Sender: TObject);
  73. begin
  74.    SetWindowLong(TargetHandle, GWL_WNDPROC, OldWindowProcAddr);
  75. end;
  76.  
  77. procedure TMyForm.FormMouseDown(Sender: TObject; Button: TMouseButton;
  78.   Shift: TShiftState; X, Y: Integer);
  79. begin
  80.   if button = mbLeft then color := clYellow;
  81.   if button = mbRight then color := clRed;
  82. end;
  83.  
  84. procedure TMyForm.Button1Click(Sender: TObject);
  85. begin
  86.   if not assigned(OnMouseDown)
  87.     then begin
  88.       OnMouseDown := FormMouseDown;
  89.       button1.caption := 'MouseDown Event Enabled';
  90.       end
  91.     else begin
  92.       OnMouseDown := nil;
  93.       button1.caption := 'MouseDown Event Disabled';
  94.       end;
  95. end;
  96.  
  97. procedure TMyForm.Button2Click(Sender: TObject);
  98. begin
  99.    SetWindowLong(TargetHandle, GWL_WNDPROC, OldWindowProcAddr);
  100.    TargetHandle := handle;
  101.    OldWindowProcAddr := GetWindowLong(TargetHandle, GWL_WNDPROC);
  102.    NewWindowProc := @AlternateNewFormFunction;
  103.    SetWindowLong(TargetHandle, GWL_WNDPROC, LongInt(NewWindowProc));
  104. end;
  105.  
  106. end.
  107.